COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE WRTPAG
C00017 ENDMK
C⊗;
	SUBROUTINE WRTPAG
	DATA SLSP/12.0/
	COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
	1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 
	1 /SF/KL,RT,KP,SIZE,NAMX,EXT /IPG/IPG
	1 ,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) 
	1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
 	1 /RCLF/KK,CL,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,ITR
	COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
	COMMON/STF/RSTFAC(0/7),RSTJ2 /IVV/IV(1) /KNUM/KNUM
	COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
	1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
	1/BRJ/JTOT,TURN,NB,DSK,PGLNTH
	DIMENSION ENDSTF(450),KPTR(50)
C  ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
	EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R7,RQ(5))
	1,(R8,RQ(6)),(LCNT,IV(45)),(NDPY,IV(46)),(ENDSTF,KBAR(4))
	DATA VERT/0.045/
C VERT IS BASIC VERTICAL UNIT SIZE IN INCHES
	IF(MPG.NE.0)GO TO 4
	DO 1 K=1,100
1	IF(NBAR(K).EQ.0)GO TO 3
3	MPG=K-1
C SETS NUMB. OF LINES ON FIRST PAGE
4	IF(SPG.EQ.0)SPG=PGLNTH/MPG
	RS=SIZE*17.5
	HX=0
CC	RA=(RSTJ2*SIZE)/RPSZ(1)
	RA=RPSZ(JPG)
C SAVE SIZE OF TOP STAFF FOR LATER
	DO 141 K=1,JPG
	RB=RSTNUM(K)
C  ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
	RHGT(K)=RHGT(K)+RB*(RS-17.5)
CC	RPSZ(K)=RPSZ(K)*RA
141	RPSZ(K)=RPSZ(K)*SIZE
CC141	HX=HX+(RHGT(K)+17.5)*RPSZ(K)*RT
CZZ	HX=(17.5*RSTNUM(JPG)+17.5)*VERT
	HX=(17.5*RSTNUM(JPG)+17.5+RHGT(JPG)*RA)*VERT
C HX=TOTAL HEIGHT IN INCHES. THIS ASSUMES RSTNUM(JPG) IS HIGHEST STAFF NUM.
C ALSO ASSUMES HIGHEST STAFF NUM. IS REALLY ABOVE ALL OTHERS.
143	IF(HX.LE.SPG)GO TO 140
	HX=SPG/HX
C GET  THE FACTOR FOR SPACE BETWEEN STAVES
CZZ	DO 142 K=1,LPG
CZZ	RA=17.5*RSTNUM(K)
CZZ142	RHGT(K)=RA*HX-RA
	RA=1/HX
	DO 142 K=1,JPG
	SP=RHGT(K)
	IF(SP)GO TO 1142
C MULT +S * <1, -S * >1  TO REDUCE SIZE
	SP=SP*HX
	GO TO 142
1142	SP=SP*RA
142	RHGT(K)=SP
CC142	RHGT(K)=(RA+RHGT(K))*HX-RA
140	NPG=1
	NMPG='PAGEA'
	HORZ=96.
	IF(KNUM.GT.0)KNUM=KNUM-1
C FOR PAGE NUMS.
	IF(MOD(KNUM,2).NE.0)HORZ=-HORZ
	RNUM=0.+KNUM
	LB=0
	ITR=LL
C TRANSPOSE IS IN LL
	RA=0
	JEND=-1
	METR=1000
	CLEF=-99
	JSLUR=0
	LC=1
	KREAD=128
	SIG=CLEF
	HX=2
	KQ=1
	KPX=1
	CALL FILOUT
C NAMQ AND NPG ARE SET IN FILOUT  
	SP=2.45
C  DEFAULT VERT. SPACE UNITS
	ENDSTF(1)=0
	IF(N.EQ.0)GO TO 100
C  SPACED OUT DEPENDING ON NUM OF LINES
	HX=N
	SP=SP+(HX-2.)*.11

100	CALL FILEIN

320	CALL STAVES
CC	IF(IPG)GO TO 3000
	IF(NPG.NE.1)GO TO 3000
	RT=RSTNUM(JPG)
	RS=100.+HORZ
	HORZ=-HORZ
	RNUM=RNUM+1
C ADDS PAGE NUMBER. SIZE(P6)=1.1  P7=3 SO PARTS PROG. WILL IGNORE IT.
	CALL STAFF(5.,10.,RS,28.,RNUM,1.1,3.0,0,0,0,0,0)
3000	IF(ITR.NE.0)CALL TRNSP
	JPQ=KL

	NA=0
	KPT=1
	ENDSTF(1)=0
C  LOOP STARTS HERE *******
131	NA=NA+1
	KWDS(KP)=JPQ
	KP=KP+1
	R=CODEN(KPN,NA,Q,JK)
	RR=Q(JK+6)
	RS=Q(JK)
	IF(R.NE.5)GO TO 935
	R8=-1
	IF(RS.GE.6)R8=Q(JK+8)
	IF(RR)GO TO 735
	IF(RR.LE.Q(JK+3))RR=202.
	GO TO 235
C CATCHES SLURS, TRILLS, 8VA, LINES THAT GO PAST END OF LINE.
935	IF(R.EQ.7)GO TO 835
	IF(R.NE.44)GO TO 35
	R=R/11.
	Q(JK+1)=R
C  INFOR FOR P9 AND L10 OF DASHES AND WIGGLES NOT KEPT YET!!!!!!!
	IF(RR.LT.Q(JK+3))GO TO 30
C  NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
835	R8=0
	R7=0
	IF(RS.GE.6)R8=Q(JK+8)
235	IF(RR.LT.199.)GO TO 30
C  P1,P2,P3,P4,P5,P6,P7,P8  ARE SAVED.
	RR=-1
735	IF(RS.GE.5)R7=Q(JK+7)
	ENDSTF(KPT)=6
	ENDSTF(KPT+1)=R
	C=Q(JK+2)
	ENDSTF(KPT+2)=C
	ENDSTF(KPT+3)=1
	ENDSTF(KPT+4)=Q(JK+4)
	ENDSTF(KPT+5)=Q(JK+5)
	ENDSTF(KPT+7)=R7
	ENDSTF(KPT+8)=R8
 	ENDSTF(KPT+6)=RR

236	KPT=KPT+13
	ENDSTF(KPT)=0
	Q(JK+6)=202
	GO TO 30
C*************
35	IF(R.NE.2)GO TO 36
	IF(RS.EQ.7)GO TO 30
C SKIP ALL THIS IF NEW CENTERING (P9 NOW HAS POS.)
	IF(RS.LT.6.)GO TO 30

	RR=RIGHT(NA,-1,JK)
	Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1,JK)-RR)/2.
C  FUNCTION 'RIGHT' FINDS ITEMS TO LFT AND RT OF REST FOR CENTERING.
C CENTERS WHOLE REST
	GO TO 30
36	IF(R.NE.3)GO TO 34
	CLEF=CLEFN(Q,JK)
	LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
	RCLEF(LL)=CLEF
	GO TO 30
34	IF(R.NE.17)GO TO 37
	SIG=Q(JK+5)
	IF(ABS(SIG).GT.100.)SIG=-99
C  DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX	IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX  CLEF # IN P6 WITH KEY SIGS.
C  NEXT CHANGES CODE NUM BACK TO ORIGINAL
37	IF(R.LT.33)GO TO 130
38	Q(JK+1)=R/11.
	GO TO 30
130	IF(Q(JK+3).LT.199)GO TO 30
	IF(R.NE.18)GO TO 30
	KKK=K+1
	R3=9
	IF(SIG.NE.-99)R3=14
	KK=JK
435	LL=KPN(KKK)
C  WDCNT,P1,P2,P3,P4,P5,P6,P7,P8
	ENDSTF(KPT)=Q(KK)
	ENDSTF(KPT+1)=R
	ENDSTF(KPT+2)=Q(KK+2)
	ENDSTF(KPT+3)=R3
	DO 535 JJ2=4,12
535	ENDSTF(KPT+JJ2)=Q(KK+JJ2)
	KPT=KPT+13
	ENDSTF(KPT)=0

	RS=Q(LL+1)
	IF(RS.LE.4)GO TO 30
	R4=Q(LL+2)
C  SAVE THE STAFF NUM. IN R4
	IF(RS.NE.18)GO TO 7011
335	R3=R3+6
	KK=LL
	KKK=KKK+1
	GO TO 435
7011	RS=CODEN(KPN,KKK+1,Q,LL)
	IF(RS.LE.4)GO TO 30
	IF(Q(LL+2).NE.R4)GO TO 30
	IF(RS.EQ.18)GO TO 335
30	JPQ=KPN(NA+1)-KPN(NA)+JPQ
	IF(NA.LT.I)GO TO 131
C  END OF LOOP ****************

	CALL PSHFT(I)
C NEXT GETS RID OF USELESS SLURS (NO LENGTH)
	K=1
441	IF(CODEN(KWDS,K,RN,J).NE.5)GO TO 41
	IF(ABS(RN(J+6)-RN(J+3)).GT..2)GO TO 41
C NEXT DELETES THE SLUR
	LL=RN(J)+3
	DO 241 NA=J,JPQ
241	RN(NA)=RN(NA+LL)
	JPQ=JPQ-LL
CCC	LL=KPN(K+2)-KPN(K+1)-LL
  	I=I-1
	KP=KP-1
	DO 341 NA=K+1,KP
341	KWDS(NA)=KWDS(NA+1)-LL
	GO TO 441
41	K=K+1
	IF(K.LT.KP-1)GO TO 441

	RS=-1
C -1 FOR ALL STAVES AT ONCE IN GETPTS.
CCC	RS=RT
	LL='J'
	R4=0
	R5=200
	NA=L
	L=KP-1 
	DO 146 K=0,JPG-1
146	RSTFAC(K)=RSTFAC(K)*SIZE
C GETS PROPER SIZE FACTORS FOR JUSTIFY SUBR.
	CALL PTMOVE(RN,KWDS)

C  START LAST LOOP *******
CC	DO 47 JJ2=1,KP
CC	LL=KWDS(JJ2)
CC	AA=RN(LL+1)
CC	IF(AA.NE.10.AND.AA.NE.16)GO TO 1047
CN	IF(AA.NE.10.AND.AA.NE.16)GO TO 347
C***** SKIP NEXT FOR NOW ******* 1/28/78
CC	GO TO 47
CC	DO 147 NN=JJ2+1,KP
CC	MM=KWDS(NN)
CC	IF(RN(MM+1).NE.16)GO TO 147
C  FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
CC	IF(RN(MM).EQ.8)GO TO 47
C  JUMP IF POS. IS ALREADY TAKEN CARE OF.
CC	IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
CC	IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
CC	AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C  SETS MINIMUM SPACE.
CC	IF(RN(MM+3).LT.AA)RN(MM+3)=AA
CC	GO TO 47
CC247	IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C  CHECKS VERT. POS.
CC	AA=RN(LL+4)+7
CC	IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C  MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
CC	GO TO 47
CC147	CONTINUE
CC	GO TO 47
CC1047	IF(AA.NE.6)GO TO 47
CC	IF(RN(LL).LT.7)GO TO 47
CC	IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER.  IT SHOULDN'T MOVE P9 ALWAYS.
CC47	CONTINUE

2	KWDS(KP)=JPQ
CP	J=1
	IF(KP.GE.300.OR.JPQ.GE.2500)TYPE 20,KP,JPQ
	JJ2=KP+1
C  WRITES 1 EXTRA WORD
CP	JPQ=KB

	DO 12 K=1,KP
CC	N=KWDS(K)
CC	R=RN(N+1)
	R=CODEN(KWDS,K,RN,N)
	IF(R.LE.2)GO TO 22
C  ONCE IT FINDS A REST OR NOTE IT MUST HAVE GONE TOO FAR.
	IF(R.GT.7)GO TO 12
 	IF(R.EQ.5)GO TO 52
	IF(R.NE.4)GO TO 62
	IF(RN(N).GE.4)GO TO 52
62	IF(R.NE.7)GO TO 12
52	A=RN(N+6)
C J HAS NOTE COUNT TO FIND POS OF RIGHT END OF SLUR.
	IF(A.GE.0)GO TO 12
	J=A
	IF(J.EQ.0)J=-1
	B=RN(N+2)
C  B=STAFF NUM.
	JJ=0

	DO 32 KK=K+1,KP
CC	NN=KWDS(KK)
CC	A=RN(NN+1)
	A=CODEN(KWDS,KK,RN,NN)
	IF(A.NE.1)GO TO 32
	IF(B.NE.RN(NN+2))GO TO 32
	D=RN(NN+3)
	JJ=JJ-1
	IF(J.NE.JJ)GO TO 42
	RN(N+6)=D+(D-A)*(RN(N+6)-J)
C FOUND NOTE FOR POSITION.
	GO TO 12
42	A=D
32	CONTINUE
12	CONTINUE
	
22	CALL PUTEXT(NAMX,EXT)
	LCNT=0
CC	NDPY=0
	RSTFAC(99)=0
C  MUST BE 0 IN MS TO MAKE DISPLAY
	CALL EXTOUT(RSTFAC,128)
	CALL EXTOUT(KWDS,JJ2)
	CALL EXTOUT(RN,JPQ)
	TYPE 101,NAMX,EXT
	NAMX=NAMX+2
CC	IF(IPG)GO TO 6011
	NPG=NPG+1
	IF(NBAR(LC).NE.0)GO TO 220
	KK=LC+1
	IF(NBAR(KK).EQ.0)GO TO 220
CHECK FOR ZEROS WHICH ARE PAGE MARKS.
	LC=LC+1
221	KK=KK+1
	IF(NBAR(KK).NE.0)GO TO 221
C  FIND NEW MPG
	MPG=KK-LC
	NPG=1000
	SPG=10./MPG
	JEND=0
C RESET ABOVE
220	IF(NPG.LE.MPG)GO TO 6011
	NPG=1
C RESET, UPDATE FILENAMES
	NAMX=NAMZ+256
	NAMZ=NAMX
6011	NAMQ=NAMX
	CALL FINEXT
	GO TO 100
C IPG=1  = GO BACK TO TRONLY INSTEAD
101	FORMAT(1XA5,'.',A3)
20	FORMAT(' TOO MUCH DATA!!! ',I3,'/300',I5,'/2500')
	END